Shareware Grab Bag/Shareware Grab Bag.iso/007/tsr25src.arc/DISABLE.PAS

Pascal/Delphi Source File | 1987-06-02 | 22.3 KB | 722 lines

{**************************************************************************
*   Activates or deactivates TSRs, while leaving them in memory.          *
*   Copyright (c) 1987 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   version 2.3 5/4/87                                                    *
*     first release. version number matches other TSR Utilities           *
*   version 2.4 5/17/87                                                   *
*     fix a bug during reactivate with more than one TSR deactivated      *
*     turn off interrupts during disable and restore                      *
*   version 2.5 6/2/87                                                    *
*     make warning messages a little more useful                          *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 3 to compile.                                  *
***************************************************************************}

{$P128}
{$C-}

program DisableTSR;
  {-Deactivate and reactivate memory resident programs}
  {-Leaving them in memory all the while}
const
  Version = '2.5';
  MaxBlocks = 128;            {Max number of DOS allocation blocks supported}

  WatchID = 'TSR WATCHER';    {Marking string for WATCH}

  {Offsets into resident copy of WATCH.COM for data storage}
  WatchOffset = $81;
  NextChange = $104;
  ChangeVectors = $220;
  OrigVectors = $620;
  CurrVectors = $A20;
  MaxChanges = 128;           {Maximum number of vector changes stored in WATCH}

type
  {.F-}
  Registers =
  record
    case Integer of
      1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
      2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  end;

  Block =
  record                      {Store info about each memory block}
    mcb : Integer;
    psp : Integer;
  end;

  BlockType = 0..MaxBlocks;
  BlockArray = array[BlockType] of Block;

  ChangeBlock =
  record                      {Store info about each vector takeover}
    VecNum : byte;
    case ID : byte of
      0, 1 : (VecOfs, VecSeg : integer);
      2    : (SaveCode : array[1..6] of byte);
      $FF  : (PspAdd : integer);
  end;
  {
  ID is interpreted as follows:
    00 = ChangeBlock holds the new pointer for vector vecnum
    01 = ChangeBlock holds pointer for vecnum but the block is disabled
    02 = ChangeBlock holds the code underneath the vector patch
    FF = ChangeBlock holds the segment of a new PSP
  }
  ChangeArray = array[0..maxchanges] of changeblock;

  HexString = string[4];
  Pathname = string[64];
  AllStrings = string[255];
  {.F+}

var
  Blocks : BlockArray;
  WatchBlock, BlockNum : BlockType;
  Regs : Registers;
  Changes : ChangeArray;
  ChangeMax, ActualMax, WatchSeg, PspHex, StartMCB : Integer;
  Activate : Boolean;
  TsrName : Pathname;

  procedure Abort(msg : AllStrings);
    {-Halt in case of error}
  begin
    WriteLn(msg);
    Halt(1);
  end {Abort} ;

  function StUpcase(s : AllStrings) : AllStrings;
    {-Return the uppercase string}
  var
    i : Byte;

  begin
    for i := 1 to Length(s) do
      s[i] := UpCase(s[i]);
    StUpcase := s;
  end {Stupcase} ;

  function Hex(i : Integer) : HexString;
    {-Return hex representation of integer}
  const
    hc : array[0..15] of Char = '0123456789ABCDEF';
  var
    l, h : Byte;
  begin
    l := Lo(i);
    h := Hi(i);
    Hex := hc[h shr 4]+hc[h and $F]+hc[l shr 4]+hc[l and $F];
  end {Hex} ;

  procedure FindTheBlocks;
    {-Scan memory for the allocated memory blocks}
  const
    MidBlockID = $4D;         {Byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {Byte DOS uses to identify last block of MCB chain}
  var
    mcbSeg : Integer;         {Segment address of current MCB}
    nextSeg : Integer;        {Computed segment address for the next MCB}
    gotFirst : Boolean;       {True after first MCB is found}
    gotLast : Boolean;        {True after last MCB is found}
    idbyte : Byte;            {Byte that DOS uses to identify an MCB}

    function GetStartMCB : Integer;
      {-Return the first MCB segment}
    begin
      Regs.ah := $52;
      MsDos(Regs);
      GetStartMCB := MemW[Regs.es:(Regs.bx-2)];
    end {Getstartmcb} ;

    procedure StoreTheBlock(var mcbSeg, nextSeg : Integer;
                            var gotFirst, gotLast : Boolean);
      {-Store information regarding the memory block}
    var
      nextID : Byte;
      PspAdd : Integer;       {Segment address of the current PSP}
      mcbLen : Integer;       {Size of the current memory block in paragraphs}

    begin

      PspAdd := MemW[mcbSeg:1]; {Address of program segment prefix for MCB}
      mcbLen := MemW[mcbSeg:3]; {Size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {Where the next MCB should be}
      nextID := Mem[nextSeg:0];

      if gotLast or (nextID = EndBlockID) or (nextID = MidBlockID) then begin
        BlockNum := Succ(BlockNum);
        gotFirst := True;
        with Blocks[BlockNum] do begin
          mcb := mcbSeg;
          psp := PspAdd;
        end;
      end;

    end {Storetheblock} ;

  begin

    {Initialize}
    StartMCB := GetStartMCB;
    mcbSeg := StartMCB;
    gotFirst := False;
    gotLast := False;
    BlockNum := 0;

    {Scan all memory until the last block is found}
    repeat
      idbyte := Mem[mcbSeg:0];
      if idbyte = MidBlockID then begin
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        if gotFirst then
          mcbSeg := nextSeg
        else
          mcbSeg := Succ(mcbSeg);
      end else if gotFirst and (idbyte = EndBlockID) then begin
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      end else
        {Start block was invalid}
        Abort('Corrupted allocation chain or program error....');
    until gotLast;

  end {Findtheblocks} ;

  function FindMark(markId : AllStrings;
                    markoffset : Integer;
                    var b : BlockType) : Boolean;
    {-Find the last memory block matching idstring at offset idoffset}
  var
    found : Boolean;

    function HasIDstring(segment : Integer;
                         idString : AllStrings;
                         idOffset : Integer) : Boolean;
      {-Return true if idstring is found at segment:idoffset}
    var
      tString : AllStrings;
      len : Byte;
    begin
      len := Length(idString);
      tString[0] := Chr(len);
      Move(Mem[segment:idOffset], tString[1], len);
      HasIDstring := (tString = idString);
    end {HasIDstring} ;

  begin
    {Scan from the last block down}
    b := BlockNum;
    found := False;
    repeat
      if Blocks[b].psp = CSeg then
        {Assure this program's command line is not matched}
        b := Pred(b)
      else if HasIDstring(Blocks[b].psp, markId, markoffset) then
        {mark found}
        found := True
      else
        {Not a mark}
        b := Pred(b);
    until (b < 1) or found;
    FindMark := found;
  end {Findmark} ;

  function ExecutableBlock(PspHex : Integer) : Boolean;
    {-Return true if psphex corresponds to an executable code block}
  var
    b : BlockType;
  begin
    for b := BlockNum downto 1 do
      {Search back to find executable rather than environment block}
      if Blocks[b].psp = PspHex then begin
        ExecutableBlock := True;
        Exit;
      end;
    ExecutableBlock := False;
  end {ExecutableBlock} ;

  procedure InitChangeArray(WatchBlock : BlockType);
    {-Initialize information regarding the WATCH data block}
  var
    watchindex : Integer;
    p : ^ChangeBlock;
  begin
    {Store the segment of the WATCH data area}
    WatchSeg := Blocks[WatchBlock].psp;

    {Maximum offset in WATCH data area}
    ActualMax := MemW[WatchSeg:NextChange];

    {Transfer changes from WATCH into a buffer array}
    watchindex := 0;
    ChangeMax := 0;
    while watchindex < ActualMax do begin
      p := Ptr(WatchSeg, ChangeVectors+watchindex);
      Move(p^, Changes[ChangeMax], SizeOf(ChangeBlock));
      watchindex := watchindex+SizeOf(ChangeBlock);
      if watchindex < ActualMax then
        ChangeMax := Succ(ChangeMax);
    end;
  end {InitChangeArray} ;

  procedure PutWatch(chg : ChangeBlock; var watchindex : Integer);
    {-Put a change block back into WATCH}
  var
    p : ^ChangeBlock;
  begin
    p := Ptr(WatchSeg, ChangeVectors+watchindex);
    Move(chg, p^, SizeOf(ChangeBlock));
    watchindex := watchindex+SizeOf(ChangeBlock);
  end {PutWatch} ;

  procedure ActivateTSR(PspHex : Integer);
    {-Patch out the active interrupt vectors of a specified TSR}
  var
    nextchg, chg, watchindex : Integer;
    checking, didsomething : Boolean;
  begin
    didsomething := False;
    watchindex := 0;
    chg := 0;

    {Scan looking for the specified PSP}
    while chg <= ChangeMax do begin
      with Changes[chg] do
        case ID of

          $FF :               {This record starts a new PSP}
            begin
              checking := (PspAdd = PspHex);
              nextchg := Succ(chg);
              if checking then
                {Turn off interrupts}
                inline($FA)
              else
                {Turn on interrupts}
                inline($FB);
            end;

          $01 :               {This record has an inactive vector redefinition}
            if checking then begin
              {We're in the proper PSP}
              didsomething := True;
              {Change the ID to indicate that vector is active}
              ID := 0;
              {Put the original vector code back in place}
              nextchg := Succ(chg);
              if (Changes[nextchg].ID <> 2) or (Changes[nextchg].VecNum <> VecNum) then
                Abort('Program error in Activate, patch record not found');
              {Restore the patched over code}
              Move(Changes[nextchg].SaveCode, Mem[VecSeg:VecOfs], 6);
              {Don't output the following patch record}
              nextchg := Succ(nextchg);
            end else
              nextchg := Succ(chg);

        else
          nextchg := Succ(chg);
        end;

      {Put the change block back into WATCH}
      PutWatch(Changes[chg], watchindex);
      {Advance to the next change record}
      chg := nextchg;
    end;

    {Store the count back into WATCH}
    MemW[WatchSeg:NextChange] := watchindex;

    if not(didsomething) then
      Abort('No changes were needed to activate '+Hex(PspHex));

  end {ActivateTSR} ;

  procedure DeactivateTSR(PspHex : Integer);
    {-Patch out the active interrupt vectors of a specified TSR}
  var
    newchange : ChangeBlock;
    chg, watchindex, curpsp : Integer;
    putrec, checking, didsomething : Boolean;
    name : pathname;

    procedure PutPatch(vecn : Byte; vecs, veco, curpsp : Integer);
      {-Patch vector entry point with JMP to previous controlling vector}
    label
      90;
    var
      vec : ^Integer;
      chg : Integer;
    begin
      {Get the original vector from WATCH}
      Move(Mem[WatchSeg:(OrigVectors+(vecn shl 2))], vec, 4);

      {Scan the Changes array to look for redefinition of this vector}
      for chg := 0 to ChangeMax do begin
        with Changes[chg] do
          case ID of
            0, 1 :            {This is or was a redefined vector}
              if vecn = VecNum then
                {It's the vector we're interested in}
                {Store the latest value of the vector}
                Move(VecOfs, vec, 4);
            $FF :             {This record starts a new PSP}
              if PspAdd = curpsp then
                {Stop when we get to the PSP that is being disabled}
                goto 90;
          end;
      end;
90:
      {Patch the vector entry point into a JMP FAR vec}
      Mem[vecs:veco] := $EA;
      Move(vec, Mem[vecs:Succ(veco)], 4);
    end {PutPatch} ;

    function CountVecs(chg : Integer) : Integer;
      {-Return count of vectors taken over by the PSP starting at changeblock chg}
    var
      count : Integer;
      ID : Byte;
    begin
      count := 0;
      repeat
        {Skip over the first one, which defines the current PSP}
        chg := Succ(chg);
        ID := Changes[chg].ID;
        if ID = 0 then
          count := Succ(count);
      until ID = $FF;
      CountVecs := count;
    end {CountVecs} ;

  begin

    {Scan looking for the specified PSP}
    didsomething := False;
    watchindex := 0;

    for chg := 0 to ChangeMax do begin
      putrec := True;
      with Changes[chg] do
        case ID of

          $FF :               {This record starts a new PSP}
            begin
              checking := (PspAdd = PspHex);
              if checking then begin
                {Store the current PSP}
                curpsp := PspAdd;
                {Make sure WATCH has room for the extra changes}
                if watchindex+(CountVecs(chg)*SizeOf(ChangeBlock)) >
                MaxChanges*SizeOf(ChangeBlock) then
                  Abort('Insufficient space in WATCH data area');
                {Turn off interrupts}
                inline($FA);
              end else
                {Turn on interrupts}
                inline($FB);
            end;

          $00 :               {This record has an active vector redefinition}
            if checking then begin
              {We're in the proper PSP}
              didsomething := True;

              {Change the ID to indicate that vector is inactive}
              ID := 1;
              {Output the record now so that the new record can immediately follow}
              PutWatch(Changes[chg], watchindex);
              putrec := False;

              {Output a new change record so we can reactivate later}
              {Indicate this is a patch record}
              newchange.ID := 2;
              {Save which vector it goes with}
              newchange.VecNum := VecNum;
              {Save the code we'll patch over}
              Move(Mem[VecSeg:VecOfs], newchange.SaveCode, 6);
              {Output the record to the WATCH area}
              PutWatch(newchange, watchindex);
              {Patch in a JMP to the previous vector}
              PutPatch(VecNum, VecSeg, VecOfs, curpsp);
            end;

        end;
      if putrec then
        {Put the change block back into WATCH}
        PutWatch(Changes[chg], watchindex);
    end;

    {Store the count back into WATCH}
    MemW[WatchSeg:NextChange] := watchindex;

    if not(didsomething) then
      Abort('No changes were needed to deactivate '+tsrname);

  end {DeactivateTSR} ;

  procedure GetOptions;
    {-Analyze command line for options}
  var
    arg : AllStrings;
    arglen : Byte absolute arg;
    i, code : Integer;

    procedure WriteHelp;
      {-Show the options}
    begin
      WriteLn('DISABLE ', Version, ', by TurboPower Software');
      WriteLn('====================================================');

      WriteLn('DISABLE allows you to selectively disable and reenable a');
      WriteLn('TSR while leaving it in memory. To run DISABLE, you must');
      WriteLn('have previously installed the TSR utility WATCH.');
      WriteLn;
      WriteLn('DISABLE is command-line driven. You specify a single TSR by');
      WriteLn('its name (if you are running DOS 3.x) or by its address as');
      WriteLn('determined from a MAPMEM report. Addresses must be preceded');
      WriteLn('by a dollar sign "$" and specified in hex.');
      WriteLn;
      WriteLn('DISABLE accepts the following command line syntax:');
      WriteLn;
      WriteLn('  DISABLE TSRname|$PSPaddress [Options]');
      WriteLn;
      WriteLn('Options may be preceded by either / or -. Valid options');
      WriteLn('are as follows:');
      WriteLn;
      WriteLn('     /A     reActivate the specified TSR.');
      WriteLn('     /?     Write this help screen.');
      Halt(1);
    end {WriteHelp} ;

    function DOSversion : Byte;
      {-return the major version number of DOS}
    var
      reg : Registers;
    begin
      reg.ah := $30;
      MsDos(reg);
      DOSversion := reg.al;
    end {dosversion} ;

    function Owner(envseg : Integer) : Pathname;
      {-return the name of the owner program of an MCB}
    type
      chararray = array[0..32767] of Char;
    var
      e : ^chararray;
      i : Integer;
      t : Pathname;

      function LongPos(m : Pathname; var s : chararray) : Integer;
        {-return the position number of m in s, or 0 if not found}
      var
        mlen : Byte absolute m;
        mc : Char;
        ss : Pathname;
        i, maxindex : Integer;
        found : Boolean;
      begin
        i := 0;
        maxindex := SizeOf(s)-mlen;
        ss[0] := m[0];
        if mlen > 0 then begin
          mc := m[1];
          repeat
            while (s[i] <> mc) and (i <= maxindex) do
              i := Succ(i);
            if s[i] = mc then begin
              Move(s[i], ss[1], Length(m));
              found := (ss = m);
              if not(found) then
                i := Succ(i);
            end;
          until found or (i > maxindex);
          if not(found) then
            i := 0;
        end;
        LongPos := i;
      end {longpos} ;

      procedure StripNonAscii(var t : Pathname);
        {-return an empty string if t contains any non-printable characters}
      var
        ipos : Byte;
        goodname : Boolean;
      begin
        goodname := True;
        for ipos := 1 to Length(t) do
          if (t[ipos] <> #0) and ((t[ipos] < ' ') or (t[ipos] > '}')) then
            goodname := False;
        if not(goodname) then
          t := '';
      end {stripnonascii} ;

      procedure StripPathname(var pname : Pathname);
        {-remove leading drive or path name from the input}
      var
        spos, cpos, rpos : Byte;
      begin
        spos := Pos('\', pname);
        cpos := Pos(':', pname);
        if spos+cpos = 0 then
          Exit;
        if spos <> 0 then begin
          {find the last slash in the pathname}
          rpos := Length(pname);
          while (rpos > 0) and (pname[rpos] <> '\') do
            rpos := Pred(rpos);
        end else
          rpos := cpos;
        Delete(pname, 1, rpos);
      end {strippathname} ;

      procedure StripExtension(var pname : Pathname);
        {-remove the file extension}
      var
        dotpos : Byte;
      begin
        dotpos := Pos('.', pname);
        if dotpos <> 0 then
          Delete(pname, dotpos, 64);
      end {stripextension} ;

    begin
      {point to the environment string}
      e := Ptr(envseg, 0);

      {find end of the standard environment}
      i := LongPos(#0#0, e^);
      if i = 0 then begin
        {something's wrong, exit gracefully}
        Owner := '';
        Exit;
      end;

      {end of environment found, get the program name that follows it}
      t := '';
      i := i+4;               {skip over #0#0#args}
      repeat
        t := t+e^[i];
        i := Succ(i);
      until (Length(t) > 64) or (e^[i] = #0);

      StripNonAscii(t);
      if t = '' then
        Owner := 'N/A'
      else begin
        StripPathname(t);
        StripExtension(t);
        if t = '' then t := 'N/A';
        Owner := StUpcase(t);
      end;

    end {owner} ;

    function FindOwner(name : AllStrings) : Integer;
      {-Return segment of executable block with specified name}
    var
      b : BlockType;
    begin
      name := StUpcase(name);
      {Scan the blocks in reverse order}
      for b := BlockNum downto 1 do
        with Blocks[b] do
          if Succ(mcb) = psp then
            {This block is an executable block}
            if Owner(MemW[psp:$2C]) = name then begin
              {Found it}
              FindOwner := psp;
              Exit;
            end;
      Abort('Cannot find TSR with name '+name);
    end {FindOwner} ;

  begin

    WriteLn;

    {Initialize defaults}
    PspHex := 0;
    Activate := False;

    i := 1;
    while i <= ParamCount do begin
      arg := ParamStr(i);
      if (arg[1] = '?') then
        WriteHelp
      else if (arg[1] = '-') or (arg[1] = '/') then
        case arglen of
          1 : Abort('Missing command option following '+arg);
          2 : case UpCase(arg[2]) of
                '?' : WriteHelp;
                'A' : Activate := True;
              else
                Abort('Unknown command option: '+arg);
              end;
        else
          Abort('Unknown command option: '+arg);
        end
      else begin
        {TSR to change}
        if arg[1] = '$' then begin
          {Treat as hex address}
          Val(arg, PspHex, code);
          if code <> 0 then
            Abort('Invalid hex address specification: '+arg);
        end else if DOSversion >= 3 then
          {Treat as PSP owner name - scan to find proper PSP}
          PspHex := FindOwner(arg)
        else
          Abort('Must have DOS 3.x to find TSRs by name');
        TsrName := StUpcase(arg);
      end;
      i := Succ(i);
    end;
    if PspHex = 0 then
      abort('No TSR name or address specified');

  end {GetOptions} ;

begin

  {Get all allocated memory blocks in normal memory}
  {Must do first to support TSRs by name in GetOptions}
  FindTheBlocks;

  {Analyze command line for options}
  GetOptions;

  {Find the watch block}
  if not(FindMark(WatchID, WatchOffset, WatchBlock)) then
    Abort('WATCH must be installed in order to use DISABLE');

  {Assure PspHex corresponds to an executable block}
  if not(ExecutableBlock(PspHex)) then
    Abort('Address specified does not correspond to a TSR');

  {Initialize information regarding the WATCH data block}
  InitChangeArray(WatchBlock);

  {Activate or deactivate the TSR}
  if Activate then
    ActivateTSR(PspHex)
  else
    DeactivateTSR(PspHex);

  {Write success message}
  Write('DISABLE ', Version, ' ');
  if not(Activate) then
    Write('de');
  Write('activated ');
  if TsrName[1] = '$' then
    Write('TSR at ');
  WriteLn(TsrName);

end.